;; This file is part of scheme-GNUnet.
;; Copyright (C) 2021 Maxime Devos
;;
;; scheme-GNUnet is free software: you can redistribute it and/or modify it
;; under the terms of the GNU Affero General Public License as published
;; by the Free Software Foundation, either version 3 of the License,
;; or (at your option) any later version.
;;
;; scheme-GNUnet is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;
;; SPDX-License-Identifier: AGPL3.0-or-later
(define-module (tests utils)
  #:use-module (srfi srfi-8)
  #:use-module ((rnrs base) #:select (assert))
  #:export (conservative-gc? calls-in-tail-position?))

;; Current versions of guile (at least 3.0.5) use a conservative
;; garbage collector, so some tests concerning garbage collection
;; might sometimes fail without indicating a bug. For reprodicible
;; builds, allow skipping these tests.

(define (conservative-gc?)
  (if (equal? "yes" (getenv "TOLERATE_CONSERVATIVE_COLLECTORS"))
      #t
      #f))

(define (calls-in-tail-position? proc)
  "Does @var{proc} calls its argument in tail position?
Additionally, return the values returned to the argument
of @var{proc} in-order. @var{proc} should not return multiple
times."
  (receive (continuation . arguments)
      (let ((t (make-prompt-tag 'tail-position?)))
	(call-with-prompt t
	  (lambda ()
	    (proc (lambda args (apply abort-to-prompt t args))))
	  (lambda _ (apply values _))))
    (apply values
	   (= 1 (stack-length (make-stack continuation)))
	   arguments)))

;; Some basic checks
(assert (calls-in-tail-position? (lambda (thunk) (thunk))))
;; TODO figure out why these fail ...
#;
(assert (not (calls-in-tail-position? (lambda (thunk) (thunk) 1))))
#;
(assert (not (calls-in-tail-position? (lambda (thunk) (+ 1 (thunk))))))
#;
(assert (not (calls-in-tail-position? (lambda (thunk) (for-each thunk '("bla" "bla"))))))
